home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Examples-2.01 / grapher.lisp < prev    next >
Encoding:
Text File  |  1993-09-16  |  12.0 KB  |  353 lines  |  [TEXT/CCL2]
  1. ;;-*- Mode: Lisp; Package: (GRAPHER (COMMON-LISP CCL)) -*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;
  4. ;;Grapher.Lisp
  5. ;;
  6. ;;Copyright © 1989, Apple Computer, Inc
  7. ;;
  8. ;;
  9. ;;  This file implements the base functionality for nodes and grapher-windows
  10. ;;  In order to use it, specific types of nodes must be defined.
  11. ;;  The commented out code at the bottom of this file is an example.
  12. ;;  Nodes should follow the node protocol by defining the the following functions:
  13. ;;    node-children --  returns a list of the node's children nodes
  14. ;;    node-parent   --  returns a list of the node's parent nodes
  15. ;;    node-draw     --  does the work of drawing a node.  usual-node-draw
  16. ;;                      should be called.
  17. ;;    node-size     --  returns a point: the size of the node.  Default: #@(150 20)
  18. ;;
  19. ;;  The redrawing could be sped up by caching the rectangles
  20. ;;  for all the nodes and lines in a quad-tree.  This would, however,
  21. ;;  consume a lot more space for a graph.
  22. ;;
  23.  
  24. ;; Mod History
  25. ;;
  26. ;; 04/28/93 mwp Release
  27. ;; 02/23/93 bill Add window-type initarg to grapher-window class
  28. ;; 01/14/93 bill Henry Lieberman's fix to layout-y so that nodes of unequal
  29. ;;               sizes will not overlap.
  30. ;; ------------- 2.0
  31. ;; 10/30/91 bill remove "-iv" on the end of slot names
  32. ;; 09/03/91 bill add defgeneric for node-children & node-parents
  33. ;; 05/01/91 bill control-meta-click does edit-definition in example code
  34. ;;               (mc's idea).
  35. ;; 03/20/91 bill add view-click-event-handler translated by Doug Currie.
  36. ;;
  37.  
  38. (defpackage :grapher (:use :common-lisp :ccl))
  39. (in-package :grapher)
  40.  
  41.  
  42. (require :scrolling-windows)
  43. (require :quickdraw)
  44.  
  45.  
  46. (declaim (ftype (function (&rest t) t) ccl::my-scroller))
  47.  
  48. ;;;;;;;;;;;;;;;;;;;;;;;;
  49. ;;
  50. ;; variables
  51. ;;
  52.  
  53. (defparameter *last-y* 0)
  54. (defparameter *x-spacing* 30)
  55. (defparameter *y-spacing* 10)
  56.  
  57. (defparameter *grapher-window-size* *window-default-size*)
  58.  
  59. ;;;;;;;;;;;;;;;
  60. ;;
  61. ;;  some utilities
  62. ;;
  63.  
  64. (defun point-max (a b)
  65.   (make-point (max (point-h a) (point-h b))
  66.               (max (point-v a) (point-v b))))
  67.  
  68. (defun point-min (a b)
  69.   (make-point (min (point-h a) (point-h b))
  70.               (min (point-v a) (point-v b))))
  71.  
  72. (defun halve-point (point)
  73.   (make-point (truncate (point-h point) 2)
  74.               (truncate (point-v point) 2)))
  75.  
  76.  
  77. ;;;;;;;;;;;;;;;;;;;
  78. ;;;
  79. ;;; node objects
  80. ;;;
  81.  
  82. (defclass node () 
  83.   ((node-position :reader node-position  :initform #@(0 0))
  84.    (node-size  :reader node-size  :initform #@(150 150))
  85.    (node-center  :reader node-center  :initform nil))
  86.    )
  87.  
  88. (defmethod set-node-position ((self node) h &optional v)
  89.   (setf (slot-value self 'node-position) (make-point h v)
  90.         (slot-value self 'node-center) nil))
  91.  
  92. (defmethod set-node-size ((self node) h &optional v)
  93.     (setf (slot-value self 'node-size) (make-point h v)
  94.         (slot-value self  'node-center) nil))
  95.  
  96. (defmethod node-center ((self node))
  97.   (or (slot-value self 'node-center)
  98.       (setf (slot-value self 'node-center)
  99.             (add-points (node-position self)
  100.                         (halve-point (node-size self))))))
  101.  
  102.  
  103.  
  104. (defmethod node-field-size ((self node) limit)
  105.   (setq limit (point-max limit
  106.                          (add-points (node-position self)
  107.                                      (node-size self))))
  108.   (dolist (child (node-children self) limit)
  109.     (setq limit (node-field-size child limit))))
  110.  
  111. (defmethod node-click-event-handler ((self node) where)
  112.   (declare (ignore where)))
  113.  
  114. (defun layout (root-node)
  115.   (graph-init root-node)
  116.   (set-node-position root-node (make-point *x-spacing*
  117.                                            (point-v (node-position root-node))))
  118.   (setq *last-y* 0)
  119.   (layout-y root-node)
  120.   (leaf-funcall #'layout-x root-node))
  121.  
  122. (defun graph-init (node)
  123.   "Zeros the coordinates of a node and all of its subnodes"
  124.     (set-node-position node #@(0 0))
  125.     (setf (slot-value node 'node-center) nil)
  126.     (mapc #'graph-init (node-children node)))
  127.  
  128. (defun layout-y (node)
  129.     (when (zerop (point-v (node-position node)))
  130.       (let ((children (node-children node)))
  131.         (if (dolist (child children)
  132.               (if (zerop (point-v (node-position child)))
  133.                 (return t)))
  134.           (progn
  135.             (mapc #'layout-y children)
  136.             (set-node-position node
  137.              (make-point (point-h (node-position node))
  138.                          (ceiling 
  139.                           (reduce #'(lambda (a b) (+ a (point-v (node-position b))))
  140.                                   children 
  141.                                   :initial-value 0)
  142.                           (length children)))))
  143.           (let ((new-y (+ *last-y* *y-spacing*)))
  144.             (set-node-position node
  145.                                (make-point (point-h (node-position node))
  146.                                            new-y))
  147.             (setf *last-y* (+ new-y (point-v (node-size node)))))))))
  148.  
  149. (defun layout-x (node &aux parents)
  150.   (let* ((pos (node-position node)))
  151.     (when (and (zerop (point-h pos))
  152.                (setq parents (node-parents node)))
  153.       (dolist (parent parents)
  154.         (layout-x parent))
  155.       (set-node-position node
  156.                          (make-point (+ *x-spacing*
  157.                                         (apply #'max (mapcar #'(lambda (node)
  158.                                                                  (point-h
  159.                                                                   (add-points (node-position node)
  160.                                                                               (node-size node))))
  161.                                                              parents)))
  162.                                      (point-v pos))))))
  163.  
  164. (defun leaf-funcall (fn node &aux (children (node-children node)))
  165.   "Calls fn on all the leaves of the graph starting at node"
  166.   (if children
  167.     (dolist (child children)
  168.       (leaf-funcall fn child))
  169.     (funcall fn node)))
  170.  
  171. (defmethod node-draw-links ((self node) &aux (children (node-children self)))
  172.   (when children
  173.     (let* ((center (node-center self)))
  174.       (dolist (child children)
  175.           (let ((child-center (node-center child)))
  176.             (#_MoveTo :long center)
  177.             (#_LineTo :long child-center))))))
  178.  
  179. (defmethod node-draw ((self node))
  180.   (let* ((children (node-children self))
  181.          (vis? (node-visible-p self))
  182.          (draw-links? (and (or vis? (node-on-right-p self))
  183.                            (some #'(lambda (kid)
  184.                                     (node-on-left-p kid))
  185.                                  children)))
  186.          (do-kids? (or draw-links? (some #'(lambda (kid)
  187.                                              (node-on-right-p kid))
  188.                                          children))))
  189.     (when draw-links?
  190.       (node-draw-links self))
  191.     (when do-kids?
  192.       (dolist (child children)
  193.        (node-draw child)))
  194.     vis?))
  195.  
  196. (defmethod node-on-right-p ((self node))
  197.   (< (point-h (node-center self))
  198.      (rref (ccl::%getport) :grafport.portrect.right)))
  199.  
  200. (defmethod node-on-left-p ((self node))
  201.   (> (point-h (node-center self)) (rref (ccl::%getport) :grafport.portrect.left)))
  202.  
  203. (defmethod node-visible-p ((self node))
  204.   (let ((pos (node-position self))
  205.         (grafrect (rref (ccl::%getport) :grafport.portrect)))
  206.     (rlet ((noderect :rect
  207.                      :topleft pos
  208.                      :bottomright (add-points pos (node-size self))))
  209.       (#_SectRect grafrect noderect noderect))))
  210.  
  211.  
  212. (defun find-node-containing-point (node point &aux ret)
  213.     (let* ((pos (node-position node)))
  214.       (rlet ((r :rect 
  215.                 :topleft pos
  216.                 :bottomright (add-points pos (node-size node))))
  217.         (if (#_PtInRect point r)
  218.           node
  219.           (dolist (child (node-children node))
  220.             (if (setq ret (find-node-containing-point child point))
  221.               (return ret)))))))
  222.  
  223. ; You must define methods for these
  224. (defgeneric node-children (node))
  225. (defgeneric node-parents (node))
  226.  
  227. ;;;;;;;;;;;;;;;;;;;;;;
  228. ;;
  229. ;; grapher window
  230. ;;
  231.  
  232. (defclass grapher-window (ccl::scrolling-window) ((root-node :initarg :root-node)))
  233.  
  234. (defmethod initialize-instance ((self grapher-window) &rest rest
  235.                                 &key (window-title "Untitled Grapher")
  236.                                 (view-font "geneva") root-node
  237.                                 window-type)
  238.   (declare (dynamic-extent rest))
  239.   (unless root-node (error "A root-node must be specified"))
  240.   (setf (slot-value self 'root-node) root-node)
  241.   (multiple-value-bind (ff ms) (font-codes view-font)
  242.     (with-font-codes ff ms              ; make string-width work right.
  243.       (layout root-node)))
  244.   (let ((field-size (add-points (make-point *x-spacing* *y-spacing*)
  245.                                 (node-field-size root-node 0))))
  246.     (without-interrupts
  247.      (apply #'call-next-method
  248.             self
  249.             :view-font view-font
  250.             :view-size (point-min field-size *grapher-window-size*)
  251.             :window-title window-title
  252.             :window-type (or window-type :document-with-zoom)
  253.             :field-size field-size
  254.             rest
  255.             )))
  256.   (set-view-font self :patcopy))
  257.  
  258. (defmethod view-draw-contents ((self grapher-window))
  259.   (call-next-method)
  260.   (with-focused-view (slot-value self  'ccl::my-scroller)
  261.     (node-draw (slot-value self 'root-node))))
  262.  
  263. (defmethod view-click-event-handler ((self grapher-window) where)
  264.   (let ((scroller (ccl::my-scroller self))
  265.         (point-view (find-view-containing-point self where)))
  266.     (if (eq point-view scroller)
  267.       (let ((node (find-node-containing-point
  268.                    (slot-value self 'root-node)
  269.                    (convert-coordinates where self scroller))))
  270.         (when node
  271.           (node-click-event-handler node where)))
  272.       (call-next-method))))
  273.  
  274. (provide :grapher)
  275.  
  276.  
  277. #|
  278.  
  279. (defclass object-node (node) 
  280.   ((my-object  :initarg :object :accessor my-object :initform (find-class 'stream))
  281.    (my-parents  :initarg :parents :accessor node-parents :initform nil)
  282.    (my-children :accessor node-children)))
  283.  
  284. (defmethod initialize-instance ((self object-node) &key)
  285.   (call-next-method)
  286.   (setf (node-children self) (mapcar #'(lambda(object)
  287.                                        (make-instance 'object-node
  288.                                                       :object object
  289.                                                       :parents (list self)))
  290.                                    (class-direct-subclasses (my-object self)))))
  291.  
  292.  
  293.  
  294. (eval-when (:compile-toplevel :load-toplevel :execute)
  295.  
  296. (defmacro with-clip-rect-intersect (rect &rest body)
  297.     (let ((old (gensym))
  298.           (new (gensym)))
  299.       `(let ((,old (#_NewRgn))
  300.              (,new (#_NewRgn)))
  301.          (#_getclip ,old)
  302.          (#_rectrgn ,new ,rect)
  303.          (#_SectRgn ,old ,new ,new)
  304.          (#_SetClip ,new)
  305.          (unwind-protect
  306.            (progn ,@body)
  307.            (#_SetClip ,old)
  308.            (#_DisposeRgn ,old)
  309.            (#_DisposeRgn ,new)))))
  310.  
  311. ) ;end eval-when
  312.  
  313. (defmethod node-draw ((self object-node))
  314.   (when (call-next-method)
  315.     (let* ((topleft (node-position self))
  316.            (left (point-h topleft))
  317.            (bottomright (add-points topleft (node-size self)))
  318.            (bottom (point-v bottomright)))
  319.       (rlet ((r :rect
  320.                 :topleft topleft
  321.                 :bottomright bottomright))
  322.         (#_eraserect r)
  323.         (#_framerect r)
  324.         (#_moveto (+ left 3) (- bottom 5))
  325.         (#_insetrect :ptr r :long #@(2 2))
  326.         (without-interrupts
  327.          (with-clip-rect-intersect r
  328.            (with-pstrs ((str (object-name-string self)))
  329.              (#_drawstring str))))))))
  330.  
  331. (defmethod object-name-string ((self object-node))
  332.         (string (class-name (my-object self))))
  333.  
  334. (defmethod node-click-event-handler ((object-node object-node) where)
  335.   (declare (ignore where))
  336.   (if (and (option-key-p)
  337.            (or (control-key-p) (command-key-p)))
  338.     (edit-definition (class-name (my-object object-node)))
  339.     (when (double-click-p)
  340.       (inspect (my-object object-node)))))
  341.  
  342. (defmethod node-size ((self object-node))
  343.   (make-point (+ 10 (string-width (object-name-string self)))
  344.               20))
  345.  
  346. (make-instance 'grapher-window
  347.        :root-node (make-instance 'object-node)
  348.        :window-title "Object Graph")
  349.               
  350.  
  351.  
  352. |#
  353.